home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / conditions.lisp < prev    next >
Text File  |  1991-06-27  |  8KB  |  231 lines
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
  2.  
  3. (in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL"))
  4.  
  5. #+kcl
  6. (eval-when (compile load eval)
  7. (when (fboundp 'remove-clcs-symbols)
  8.   (remove-clcs-symbols))
  9. )
  10.  
  11. ;DEFINE-CONDITION
  12. ;MAKE-CONDITION
  13. ;condition printing
  14. ;(define-condition CONDITION ...)
  15. ;CONDITIONP
  16. ;CONDITION-CLASS-P
  17. ;SIMPLE-CONDITION-P
  18. ;SIMPLE-CONDITION-CLASS-P
  19.  
  20. #-(or clos pcl)
  21. (progn
  22. (DEFUN CONDITION-PRINT (CONDITION STREAM DEPTH)
  23.   DEPTH ;ignored
  24.   (COND (*PRINT-ESCAPE*
  25.          (FORMAT STREAM "#<~S.~D>" (TYPE-OF CONDITION) (UNIQUE-ID CONDITION)))
  26.         (T
  27.          (CONDITION-REPORT CONDITION STREAM))))
  28.  
  29. (DEFSTRUCT (CONDITION :CONC-NAME
  30.                       (:CONSTRUCTOR |Constructor for CONDITION|)
  31.                       (:PREDICATE NIL)
  32.                       (:PRINT-FUNCTION CONDITION-PRINT))
  33.   (-DUMMY-SLOT- NIL))
  34.  
  35. (EVAL-WHEN (EVAL COMPILE LOAD)
  36.  
  37. (DEFMACRO PARENT-TYPE     (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'PARENT-TYPE))
  38. (DEFMACRO SLOTS           (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'SLOTS))
  39. (DEFMACRO CONC-NAME       (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'CONC-NAME))
  40. (DEFMACRO REPORT-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'REPORT-FUNCTION))
  41. (DEFMACRO MAKE-FUNCTION   (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'MAKE-FUNCTION))
  42.  
  43. );NEHW-LAVE
  44.  
  45. (DEFUN CONDITION-REPORT (CONDITION STREAM)
  46.   (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE)))
  47.       ((NOT TYPE) (FORMAT STREAM "The condition ~A occurred." (TYPE-OF CONDITION)))
  48.     (LET ((REPORTER (REPORT-FUNCTION TYPE)))
  49.       (WHEN REPORTER
  50.         (FUNCALL REPORTER CONDITION STREAM)
  51.         (RETURN NIL)))))
  52.  
  53. (SETF (MAKE-FUNCTION   'CONDITION) '|Constructor for CONDITION|)
  54.  
  55. (DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)
  56.   (LET ((FN (MAKE-FUNCTION TYPE)))
  57.     (COND ((NOT FN) (ERROR 'SIMPLE-TYPE-ERROR
  58.                :DATUM TYPE
  59.                :EXPECTED-TYPE '(SATISFIES MAKE-FUNCTION)
  60.                :FORMAT-STRING "Not a condition type: ~S"
  61.                :FORMAT-ARGUMENTS (LIST TYPE)))
  62.           (T (APPLY FN SLOT-INITIALIZATIONS)))))
  63.  
  64. (EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time
  65.  
  66. (DEFUN PARSE-NEW-AND-USED-SLOTS (SLOTS PARENT-TYPE)
  67.   (LET ((NEW '()) (USED '()))
  68.     (DOLIST (SLOT SLOTS)
  69.       (IF (SLOT-USED-P (CAR SLOT) PARENT-TYPE)
  70.           (PUSH SLOT USED)
  71.           (PUSH SLOT NEW)))
  72.     (VALUES NEW USED)))
  73.  
  74. (DEFUN SLOT-USED-P (SLOT-NAME TYPE)
  75.   (COND ((EQ TYPE 'CONDITION) NIL)
  76.         ((NOT TYPE) (ERROR "The type ~S does not inherit from CONDITION." TYPE))
  77.         ((ASSOC SLOT-NAME (SLOTS TYPE)))
  78.         (T
  79.          (SLOT-USED-P SLOT-NAME (PARENT-TYPE TYPE)))))
  80.  
  81. );NEHW-LAVE
  82.  
  83. (DEFMACRO DEFINE-CONDITION (NAME (PARENT-TYPE) SLOT-SPECS &REST OPTIONS)
  84.   (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*)) ;Bind for the INTERN -and- the FORMAT
  85.                        (INTERN (FORMAT NIL "Constructor for ~S" NAME)))))
  86.     (LET ((SLOTS (MAPCAR #'(LAMBDA (SLOT-SPEC)
  87.                  (IF (ATOM SLOT-SPEC) (LIST SLOT-SPEC) SLOT-SPEC))
  88.              SLOT-SPECS)))
  89.       (MULTIPLE-VALUE-BIND (NEW-SLOTS USED-SLOTS)
  90.           (PARSE-NEW-AND-USED-SLOTS SLOTS PARENT-TYPE)
  91.     (LET ((CONC-NAME-P     NIL)
  92.           (CONC-NAME       NIL)
  93.           (REPORT-FUNCTION NIL)
  94.           (DOCUMENTATION   NIL))
  95.       (DO ((O OPTIONS (CDR O)))
  96.           ((NULL O))
  97.         (LET ((OPTION (CAR O)))
  98.           (CASE (CAR OPTION) ;Should be ECASE
  99.         (:CONC-NAME (SETQ CONC-NAME-P T)
  100.                  (SETQ CONC-NAME (CADR OPTION)))
  101.         (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION))
  102.                            `(LAMBDA (CONDITION STREAM)
  103.                               (DECLARE (IGNORE CONDITION))
  104.                               (WRITE-STRING ,(CADR OPTION) STREAM))
  105.                            (CADR OPTION))))
  106.         (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION)))
  107.         (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option."
  108.                    "Invalid DEFINE-CONDITION option: ~S" OPTION)))))
  109.       (IF (NOT CONC-NAME-P) (SETQ CONC-NAME (INTERN (FORMAT NIL "~A-" NAME) *PACKAGE*)))
  110.           ;; The following three forms are compile-time side-effects. For now, they affect
  111.           ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, 
  112.           ;; and CONC-NAME, the compiler could easily make them local.
  113.           (SETF (PARENT-TYPE NAME) PARENT-TYPE)
  114.           (SETF (SLOTS NAME)       SLOTS)
  115.           (SETF (CONC-NAME NAME)   CONC-NAME)
  116.           ;; Finally, the expansion ...
  117.           `(PROGN (DEFSTRUCT (,NAME
  118.                               (:CONSTRUCTOR ,CONSTRUCTOR)
  119.                               (:PREDICATE NIL)
  120.                   (:COPIER NIL)
  121.                               (:PRINT-FUNCTION CONDITION-PRINT)
  122.                               (:INCLUDE ,PARENT-TYPE ,@USED-SLOTS)
  123.                               (:CONC-NAME ,CONC-NAME))
  124.                     ,@NEW-SLOTS)
  125.           (SETF (DOCUMENTATION ',NAME 'TYPE) ',DOCUMENTATION)
  126.                   (SETF (PARENT-TYPE ',NAME) ',PARENT-TYPE)
  127.                   (SETF (SLOTS ',NAME) ',SLOTS)
  128.                   (SETF (CONC-NAME ',NAME) ',CONC-NAME)
  129.                   (SETF (REPORT-FUNCTION ',NAME) ,(IF REPORT-FUNCTION `#',REPORT-FUNCTION))
  130.                   (SETF (MAKE-FUNCTION ',NAME) ',CONSTRUCTOR)
  131.                   ',NAME))))))
  132.  
  133. (defun conditionp (object)
  134.   (typep object 'condition))
  135.  
  136. (defun condition-class-p (object)
  137.   (and (symbolp object)
  138.        (MAKE-FUNCTION object)))
  139.  
  140. )
  141.  
  142.  
  143.  
  144. #+(or clos pcl)
  145. (progn
  146.  
  147. (eval-when (compile load eval)
  148. (defvar *condition-class-list* nil) ; list of (class-name initarg1 type1...)
  149. )
  150.  
  151. (DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS)
  152.   (let* ((REPORT-FUNCTION nil)
  153.      (DOCUMENTATION nil))
  154.     (DO ((O OPTIONS (CDR O)))
  155.     ((NULL O))
  156.       (LET ((OPTION (CAR O)))
  157.     (CASE (CAR OPTION)
  158.       (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION))
  159.                          `(LAMBDA (CONDITION STREAM)
  160.                             (DECLARE (IGNORE CONDITION))
  161.                             (WRITE-STRING ,(CADR OPTION) STREAM))
  162.                          (CADR OPTION))))
  163.       (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION)))
  164.       (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option."
  165.                  "Invalid DEFINE-CONDITION option: ~S" OPTION)))))
  166.     `(progn
  167.        (eval-when (compile)
  168.      #+pcl (setq pcl::*defclass-times* '(compile load eval)))
  169.        (defclass ,name ,parent-list
  170.      ,slot-specs)
  171.        (eval-when (compile load eval)
  172.      (pushnew '(,name ,parent-list
  173.             ,@(mapcan #'(lambda (slot-spec)
  174.                   (let* ((ia (getf (cdr slot-spec) ':initarg)))
  175.                     (when ia
  176.                       (list
  177.                        (cons ia
  178.                          (or (getf (cdr slot-spec) ':type)
  179.                          t))))))
  180.                SLOT-SPECS))
  181.           *condition-class-list*)
  182.      #+kcl (setf (get ',name #+akcl 'si::s-data #-akcl 'si::is-a-structure) nil)
  183.      (setf (get ',name 'documentation) ',documentation))
  184.       ,@(when REPORT-FUNCTION
  185.        `((DEFMETHOD PRINT-OBJECT ((X ,NAME) STREAM)
  186.            (IF *PRINT-ESCAPE*
  187.            (CALL-NEXT-METHOD)
  188.            (,REPORT-FUNCTION X STREAM)))))
  189.       ',NAME)))
  190.  
  191. (eval-when (compile load eval)
  192. (define-condition condition ()
  193.   ())
  194.  
  195. #+pcl
  196. (when (fboundp 'pcl::proclaim-incompatible-superclasses)
  197.   (mapc
  198.    #'pcl::proclaim-incompatible-superclasses
  199.    '((condition pcl::metaobject))))
  200. )
  201.  
  202. (defun conditionp (object)
  203.   (typep object 'condition))
  204.  
  205. (DEFMETHOD PRINT-OBJECT ((X condition) STREAM)
  206.   (IF *PRINT-ESCAPE* 
  207.       (FORMAT STREAM "#<~S.~D>" (class-name (class-of x)) (UNIQUE-ID x))
  208.       (FORMAT STREAM "The condition ~A occurred." (TYPE-OF x))))
  209.  
  210. (defvar *condition-class* (find-class 'condition))
  211.  
  212. (defun condition-class-p (TYPE)
  213.   (when (symbolp TYPE)
  214.     (setq TYPE (find-class TYPE)))
  215.   (and (typep TYPE 'standard-class)
  216.        (member *condition-class* 
  217.            (#+pcl pcl::class-precedence-list
  218.         #-pcl clos::class-precedence-list
  219.           type))))
  220.  
  221. (DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)
  222.   (unless (condition-class-p TYPE)
  223.     (ERROR 'SIMPLE-TYPE-ERROR
  224.        :DATUM TYPE
  225.        :EXPECTED-TYPE '(SATISFIES condition-class-p)
  226.        :FORMAT-STRING "Not a condition type: ~S"
  227.        :FORMAT-ARGUMENTS (LIST TYPE)))
  228.   (apply #'make-instance TYPE SLOT-INITIALIZATIONS))
  229.  
  230. )
  231.